home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
An Invitation to the Roland World of Music
/
Roland - An Invitation To The Roland World Of Music.bin
/
vb
/
cooltool
/
mfedit
/
mfedit.frm
next >
Wrap
Text File
|
1995-04-20
|
36KB
|
1,178 lines
VERSION 2.00
Begin Form Form1
AutoRedraw = -1 'True
BackColor = &H00C0C0C0&
BorderStyle = 3 'Fixed Double
Caption = "MFEDIT"
ClientHeight = 5355
ClientLeft = 720
ClientTop = 2070
ClientWidth = 9240
Height = 6045
Icon = MFEDIT.FRX:0000
Left = 660
LinkTopic = "Form1"
MaxButton = 0 'False
ScaleHeight = 5355
ScaleWidth = 9240
Top = 1440
Width = 9360
Begin Frame Frame3
BackColor = &H00C0C0C0&
Caption = "Playback Rate"
Height = 855
Left = 7080
TabIndex = 12
Top = 2220
Width = 2055
Begin HSlider PlaybackRateSlider
BackColor = &H00C0C0C0&
BevelInner = 1 'Raised
BevelOuter = 0 'None
BevelWidth = 2
BorderWidth = 2
Gap = 3
Height = 435
LargeChange = 10
Left = 120
LinkControl = "MIDIOutput1"
LinkProperty = "PlaybackRate"
Max = 100
Min = -100
ThumbHeight = 340
ThumbStyle = 2 'Pointed Down
ThumbWidth = 120
TickColor = &H00000000&
TickCount = 20
TickLength = 4
TickMarks = 2 'Bottom
TickWidth = 1
Top = 300
TrackBevel = 2 'Inset
TrackWidth = 2
Value = 0
Width = 1815
End
End
Begin Frame Frame5
BackColor = &H00C0C0C0&
Caption = "Playback Controls"
Height = 2115
Left = 7080
TabIndex = 30
Top = 3180
Width = 2055
Begin CommandButton CmdStop
Caption = "Stop"
Height = 435
Left = 120
TabIndex = 31
Top = 1500
Width = 1815
End
Begin CommandButton CmdRecord
Caption = "Record"
Height = 435
Left = 120
TabIndex = 32
Top = 900
Width = 1815
End
Begin CommandButton CmdPlay
Caption = "Play"
Height = 435
Left = 120
TabIndex = 33
Top = 300
Width = 1815
End
End
Begin Frame Frame4
BackColor = &H00C0C0C0&
Caption = "MIDI File Settings"
Height = 2175
Left = 7080
TabIndex = 36
Top = -30
Width = 2055
Begin Label LabelTicks
Alignment = 2 'Center
BackColor = &H00000000&
Caption = "Tick"
FontBold = 0 'False
FontItalic = 0 'False
FontName = "MS Sans Serif"
FontSize = 9.75
FontStrikethru = 0 'False
FontUnderline = 0 'False
ForeColor = &H0000FF00&
Height = 255
Left = 240
TabIndex = 37
Top = 1800
Width = 1635
End
Begin Label LabelTimeSignature
Alignment = 2 'Center
BackColor = &H00000000&
BorderStyle = 1 'Fixed Single
Caption = "Time Signature"
FontBold = 0 'False
FontItalic = 0 'False
FontName = "MS Sans Serif"
FontSize = 9.75
FontStrikethru = 0 'False
FontUnderline = 0 'False
ForeColor = &H0000FF00&
Height = 315
Left = 240
TabIndex = 34
Top = 540
Width = 1635
End
Begin Label LabelTempo
Alignment = 2 'Center
BackColor = &H00000000&
BorderStyle = 1 'Fixed Single
Caption = "Tempo"
FontBold = 0 'False
FontItalic = 0 'False
FontName = "MS Sans Serif"
FontSize = 9.75
FontStrikethru = 0 'False
FontUnderline = 0 'False
ForeColor = &H0000FF00&
Height = 315
Left = 240
TabIndex = 35
Top = 1140
Width = 1635
End
Begin Label Label7
Alignment = 2 'Center
BackColor = &H00C0C0C0&
Caption = "Time Signature"
FontBold = 0 'False
FontItalic = 0 'False
FontName = "MS Sans Serif"
FontSize = 9.75
FontStrikethru = 0 'False
FontUnderline = 0 'False
Height = 255
Left = 120
TabIndex = 40
Top = 300
Width = 1815
End
Begin Label Label8
Alignment = 2 'Center
BackColor = &H00C0C0C0&
Caption = "Tempo"
FontBold = 0 'False
FontItalic = 0 'False
FontName = "MS Sans Serif"
FontSize = 9.75
FontStrikethru = 0 'False
FontUnderline = 0 'False
Height = 255
Left = 120
TabIndex = 39
Top = 900
Width = 1815
End
Begin Label Label9
Alignment = 2 'Center
BackColor = &H00C0C0C0&
Caption = "Ticks Per Quarter Note"
FontBold = 0 'False
FontItalic = 0 'False
FontName = "MS Sans Serif"
FontSize = 8.25
FontStrikethru = 0 'False
FontUnderline = 0 'False
Height = 255
Left = 120
TabIndex = 38
Top = 1560
Width = 1815
End
End
Begin MIDIFile MIDIFile1
Filename = ""
Left = 1440
ReadOnly = 0 'False
Top = 5340
End
Begin MIDIInput MIDIInput1
DeviceID = 0
Left = 1860
MaxSysexSize = 32000
MessageEventEnable= 0 'False
Top = 5340
End
Begin PictureBox Picture1
BackColor = &H00C0C0C0&
BorderStyle = 0 'None
Height = 435
Left = 60
ScaleHeight = 435
ScaleWidth = 6915
TabIndex = 19
Top = 30
Width = 6915
Begin CheckBox MidiThruCheck
BackColor = &H00C0C0C0&
Caption = "Midi Thru"
Height = 255
Left = 2820
TabIndex = 22
Top = 60
Value = 1 'Checked
Width = 1155
End
Begin ComboBox InputDevCombo
Height = 300
Left = 60
Style = 2 'Dropdown List
TabIndex = 18
Top = 60
Width = 2535
End
Begin ComboBox OutputDevCombo
Height = 300
Left = 4140
Style = 2 'Dropdown List
TabIndex = 20
Top = 60
Width = 2535
End
End
Begin Frame Frame2
BackColor = &H00C0C0C0&
Caption = "Tracks"
ForeColor = &H00000000&
Height = 4755
Left = 60
TabIndex = 13
Top = 540
Width = 3195
Begin ListBox TrackList
Height = 2955
Left = 120
TabIndex = 17
Top = 300
Width = 2955
End
Begin CommandButton CmdInsertTrack
Caption = "Insert New Track"
Height = 435
Left = 120
TabIndex = 16
Top = 4260
Width = 2955
End
Begin CommandButton CmdDeleteTrack
Caption = "Delete Current Track"
Height = 435
Left = 120
TabIndex = 15
Top = 3780
Width = 2955
End
Begin CommandButton CmdQueueTrack
Caption = "Queue Current Track"
Height = 435
Left = 120
TabIndex = 14
Top = 3300
Width = 2955
End
End
Begin MIDIOutput MIDIOutput1
DeviceID = 0
Left = 2280
Top = 5340
VolumeLeft = 0
VolumeRight = 0
End
Begin CommonDialog CMDialog1
CancelError = -1 'True
DefaultExt = "mid"
DialogTitle = "Open MIDI File"
Filter = "(*.mid) MIDI files|*.mid|"
Left = 2700
Top = 5340
End
Begin Frame Frame1
BackColor = &H00C0C0C0&
Caption = "Messages"
Height = 4755
Left = 3300
TabIndex = 4
Top = 540
Width = 3675
Begin PictureBox Picture2
BackColor = &H00C0C0C0&
BorderStyle = 0 'None
Height = 1875
Left = 120
ScaleHeight = 1875
ScaleWidth = 3495
TabIndex = 23
Top = 2820
Width = 3495
Begin TextBox MessageEdit
Height = 285
Left = 1020
TabIndex = 29
Top = 60
Width = 555
End
Begin TextBox Data1Edit
Height = 285
Left = 1020
TabIndex = 28
Top = 420
Width = 555
End
Begin TextBox Data2Edit
Height = 285
Left = 2700
TabIndex = 27
Top = 420
Width = 555
End
Begin TextBox TimeEdit
Height = 285
Left = 1020
TabIndex = 26
Top = 780
Width = 1035
End
Begin TextBox BufferEdit
Height = 285
Left = 1020
TabIndex = 25
Top = 1140
Width = 2415
End
Begin TextBox MsgTextEdit
Height = 285
Left = 1020
TabIndex = 24
Top = 1500
Width = 2415
End
Begin Label Label1
Alignment = 1 'Right Justify
BackColor = &H00C0C0C0&
Caption = "Message:"
Height = 255
Left = 60
TabIndex = 6
Top = 60
Width = 855
End
Begin Label Label2
Alignment = 1 'Right Justify
BackColor = &H00C0C0C0&
Caption = "Data1:"
Height = 255
Left = 60
TabIndex = 7
Top = 420
Width = 855
End
Begin Label Label3
Alignment = 1 'Right Justify
BackColor = &H00C0C0C0&
Caption = "Data2:"
Height = 255
Left = 1740
TabIndex = 8
Top = 420
Width = 855
End
Begin Label Label4
Alignment = 1 'Right Justify
BackColor = &H00C0C0C0&
Caption = "Buffer:"
Height = 255
Left = 60
TabIndex = 9
Top = 1140
Width = 855
End
Begin Label Label5
Alignment = 1 'Right Justify
BackColor = &H00C0C0C0&
Caption = "Time:"
Height = 255
Left = 60
TabIndex = 10
Top = 780
Width = 855
End
Begin Label Label6
BackColor = &H00C0C0C0&
Caption = "MsgText:"
Height = 255
Left = 120
TabIndex = 11
Top = 1500
Width = 795
End
End
Begin CheckBox InsertRecordingCheck
BackColor = &H00C0C0C0&
Caption = "Insert Recording"
Height = 255
Left = 1620
TabIndex = 21
Top = 2520
Width = 1755
End
Begin CommandButton CmdDeleteMessage
Caption = "Delete"
Height = 315
Left = 2700
TabIndex = 0
Top = 2160
Width = 855
End
Begin CommandButton CmdInsertMessage
Caption = "Insert"
Height = 315
Left = 1440
TabIndex = 1
Top = 2160
Width = 855
End
Begin CommandButton CmdModifyMessage
Caption = "Modify"
Height = 315
Left = 120
TabIndex = 2
Top = 2160
Width = 855
End
Begin CheckBox HexCheck
BackColor = &H00C0C0C0&
Caption = "Hexadecimal"
Height = 255
Left = 180
TabIndex = 3
Top = 2520
Value = 1 'Checked
Width = 1455
End
Begin ListBox MessageList
Height = 1785
Left = 120
TabIndex = 5
Top = 300
Width = 3435
End
End
Begin Menu FileMenu
Caption = "&File"
Begin Menu FileNew
Caption = "&New"
Shortcut = ^N
End
Begin Menu FileOpen
Caption = "&Open..."
Shortcut = ^O
End
Begin Menu FileSep1
Caption = "-"
End
Begin Menu FileSave
Caption = "&Save"
Shortcut = ^S
End
Begin Menu FileSaveAs
Caption = "Save &As..."
End
Begin Menu FileSep2
Caption = "-"
End
Begin Menu FileExit
Caption = "E&xit"
End
End
End
Option Explicit
Dim lVolume As Integer
Dim rVolume As Integer
Dim msPerTick(50) As Long
Dim ticksPerMs(50) As Long
Dim fModified As Integer
Dim fGotFirst As Integer
Dim fRecording As Integer
Dim CurrentTime As Double
Dim PreviousTime As Double
Dim InCurrentTime As Double
Dim InPreviousTime As Double
Dim TempoTime(50) As Long
Dim TempoSetting(50) As Long
Dim TotalTempoChanges As Integer
Dim Lyric(1000) As String
Sub CloseInputDevice ()
'
' Close if open
'
If MIDIInput1.State >= MIDISTATE_OPEN Then
MIDIInput1.Action = MIDIIN_CLOSE
End If
End Sub
Sub CloseOutputDevice ()
'
' Restore volume before closing
'
If MIDIOutput1.State >= MIDISTATE_OPEN Then
If (MIDIOutput1.HasLRVolume) Then
MIDIOutput1.VolumeLeft = lVolume
MIDIOutput1.VolumeRight = rVolume
ElseIf (MIDIOutput1.HasVolume) Then
MIDIOutput1.VolumeLeft = lVolume
End If
'
' Close
'
MIDIOutput1.Action = MIDIOUT_CLOSE
End If
End Sub
Sub CmdDeleteMessage_Click ()
MIDIFile1.Action = MIDIFILE_DELETE_MESSAGE
fModified = True
DisplayTrack (TrackList.ListIndex + 1)
End Sub
Sub CmdDeleteTrack_Click ()
Dim t As Integer
MIDIFile1.TrackNumber = TrackList.ListIndex + 1
MIDIFile1.Action = MIDIFILE_DELETE_TRACK
fModified = True
t = TrackList.ListIndex
DisplayTrackList
If (t > TrackList.ListCount - 1) Then
t = t - 1
End If
TrackList.ListIndex = t
End Sub
Sub CmdInsertMessage_Click ()
MIDIFile1.Message = FetchNumber(CStr(MessageEdit.Text))
MIDIFile1.Data1 = FetchNumber(CStr(Data1Edit.Text))
MIDIFile1.Data2 = FetchNumber(CStr(Data2Edit.Text))
MIDIFile1.Time = FetchNumber(CStr(TimeEdit.Text))
MIDIFile1.Action = MIDIFILE_INSERT_MESSAGE
fModified = True
DisplayTrack (TrackList.ListIndex + 1)
End Sub
Sub CmdInsertTrack_Click ()
Dim t As Integer
MIDIFile1.TrackNumber = TrackList.ListIndex + 1
MIDIFile1.Action = MIDIFILE_INSERT_TRACK
fModified = True
t = TrackList.ListIndex
DisplayTrackList
TrackList.ListIndex = t + 1
End Sub
Sub CmdModifyMessage_Click ()
Dim m As Integer
MIDIFile1.Message = FetchNumber(CStr(MessageEdit.Text))
MIDIFile1.Data1 = FetchNumber(CStr(Data1Edit.Text))
MIDIFile1.Data2 = FetchNumber(CStr(Data2Edit.Text))
MIDIFile1.Time = FetchNumber(CStr(TimeEdit.Text))
MIDIFile1.Buffer = BufferEdit.Text
MIDIFile1.MsgText = MsgTextEdit.Text
MIDIFile1.Action = MIDIFILE_MODIFY_MESSAGE
m = MIDIFile1.MessageNumber
fModified = True
DisplayTrack (TrackList.ListIndex + 1)
If (m > MIDIFile1.MessageCount) Then
m = m - 1
End If
MessageList.ListIndex = m
End Sub
Sub CmdPlay_Click ()
StartPlay
End Sub
Sub CmdQueueTrack_Click ()
QueueTrack (TrackList.ListIndex + 1)
On Error Resume Next
TrackList.ListIndex = TrackList.ListIndex + 1
On Error GoTo 0
End Sub
Sub CmdRecord_Click ()
InsertRecordingCheck.Value = 1
StartPlay
StartRecording
End Sub
Sub CmdStop_Click ()
StopPlay
StopRecording
End Sub
Sub DisplayTrack (t As Integer)
Dim i As Integer
Screen.MousePointer = 11
MessageList.Clear
MIDIFile1.TrackNumber = t
For i = 1 To MIDIFile1.MessageCount
If (i > 500) Then
Exit For
End If
MIDIFile1.MessageNumber = i
'
'Meta Event
'
If (MIDIFile1.Message = 255) Then
Select Case MIDIFile1.Data1
Case 0 'Sequence number
MessageList.AddItem "Sequence number " & Hex$(MIDIFile1.Data2) & " : " & MIDIFile1.MsgText
Case 1 'Text
MessageList.AddItem "Text " & Hex$(MIDIFile1.Data1) & " : " & MIDIFile1.MsgText
Case 2 'Copyright
MessageList.AddItem "Copyright " & Hex$(MIDIFile1.Data1) & " : " & MIDIFile1.MsgText
Case 3 'track name
MessageList.AddItem "Track Name " & Hex$(MIDIFile1.Data1) & " : " & MIDIFile1.MsgText
Case 4 'instrument name
MessageList.AddItem "Instrument Name " & Hex$(MIDIFile1.Data1) & " : " & MIDIFile1.MsgText
Case 5 'Lyric
MessageList.AddItem "Lyric " & Hex$(MIDIFile1.Data1) & " : " & MIDIFile1.MsgText
Case 6 'Marker
MessageList.AddItem "Marker " & Hex$(MIDIFile1.Data1) & " : " & MIDIFile1.MsgText
Case 7 'Cue point
MessageList.AddItem "Cue point " & Hex$(MIDIFile1.Data1) & " : " & MIDIFile1.MsgText
' Case &H51 '81
MessageList.AddItem Str(MIDIFile1.Time) & " Tempo " & Int(60000000 / MIDIFile1.Tempo)
' Label4.Caption = Int(60000000 / MIDIFile1.Tempo)
' HSliderTempo.Value = Int(60000000 / MIDIFile1.Tempo)
' Case &H58 '88
MessageList.AddItem Str(MIDIFile1.Time) & " Time Signature " & MIDIFile1.Numerator + "/" & (MIDIFile1.Denominator ^ 2)
' lblTimeSig.Caption = MIDIFile1.Numerator & "/" & MIDIFile1.Denominator ^ 2
Case Else
MessageList.AddItem "Sysex " & Hex$(MIDIFile1.Data1)
End Select
Else
MessageList.AddItem Hex$(MIDIFile1.Message)
End If
Next
Screen.MousePointer = 0
End Sub
Sub DisplayTrackList ()
Dim m As Integer
Dim t As Integer
TrackList.Clear
For t = 1 To MIDIFile1.NumberOfTracks
TrackList.AddItem GetTrackName(t)
Next
GetTempoChanges
GetTimeSignature
End Sub
Function FetchNumber (s As String) As Integer
If (HexCheck.Value) Then
FetchNumber = Val("&H" & s)
Else
FetchNumber = Val(s)
End If
End Function
Sub FileExit_Click ()
If (OkToExit()) Then
End
End If
End Sub
Sub FileNew_Click ()
Dim wRtn As Integer
Dim ts As Variant
If (fModified) Then
wRtn = MsgBox("Discard changes to current file?", 36)
If (wRtn <> 6) Then
Exit Sub
End If
End If
MIDIFile1.Filename = "Untitled.mid"
Form1.Caption = "Untitled.mid"
On Error Resume Next
ts = FileDateTime("Untitled.mid")
wRtn = Err
On Error GoTo 0
If (wRtn = 0) Then
wRtn = MsgBox("Untitled.mid already exists, do you want to recreate it?", 36)
If (wRtn = 6) Then
Kill "Untitled.mid"
wRtn = 1
Else
wRtn = 0
End If
Else
wRtn = 1
End If
If (wRtn) Then
MIDIFile1.Action = MIDIFILE_CREATE
MIDIFile1.Action = MIDIFILE_SAVE
Else
MIDIFile1.Action = MIDIFILE_OPEN
End If
DisplayTrackList
TrackList.ListIndex = 0
fModified = 0
End Sub
Sub FileOpen_Click ()
On Error Resume Next
CMDialog1.DialogTitle = "Open MIDI File"
CMDialog1.Flags = &H1000&
CMDialog1.Action = 1
If (Err) Then
Exit Sub
End If
MIDIFile1.Filename = CMDialog1.Filename
MIDIFile1.Action = MIDIFILE_OPEN
DisplayTrackList
TrackList.ListIndex = 1
fModified = 0
End Sub
Sub FileSave_Click ()
MIDIFile1.Action = MIDIFILE_SAVE
End Sub
Sub FileSaveAs_Click ()
If (SaveAs()) Then
Form1.Caption = CMDialog1.Filename
End If
End Sub
Sub Form_Load ()
Dim i As Integer
'
' Fill output device combo box
'
For i = -1 To MIDIOutput1.DeviceCount - 1
MIDIOutput1.DeviceID = i
OutputDevCombo.AddItem MIDIOutput1.ProductName
Next
'
' Select first in list
'
MIDIOutput1.DeviceID = -1
OutputDevCombo.ListIndex = 0
'
' Fill input device combo box
'
For i = 0 To MIDIInput1.DeviceCount - 1
MIDIInput1.DeviceID = i
InputDevCombo.AddItem MIDIInput1.ProductName
Next
'
' Select first in list
'
MIDIInput1.DeviceID = -1
InputDevCombo.ListIndex = 0
fModified = 0
Form1.Show
HighLight Picture1, 1
HighLight Picture2, 1
HighLight Frame1, 1
HighLight Frame2, 1
End Sub
Sub Form_QueryUnload (Cancel As Integer, UnloadMode As Integer)
If (OkToExit() <> True) Then
Cancel = True
End If
End Sub
Sub Form_Unload (Cancel As Integer)
CloseOutputDevice
CloseInputDevice
End Sub
Function FormatNumber (n As Long) As String
If (HexCheck.Value) Then
FormatNumber = Hex$(n)
Else
FormatNumber = Format(n)
End If
End Function
Sub GetTempoChanges ()
Dim m As Integer
Dim TempoChangeCount As Integer
Dim CurrentTime As Long
Screen.MousePointer = 11
TotalTempoChanges = 0
MIDIFile1.TrackNumber = 1
For m = 1 To MIDIFile1.MessageCount
MIDIFile1.MessageNumber = m
'Meta Tempo Event
If (MIDIFile1.Message = 255) And MIDIFile1.Data1 = &H51 Then
'Keep track of the total number of tempo changes in this MIDI file
TotalTempoChanges = TotalTempoChanges + 1
'This is the tempo
TempoSetting(TotalTempoChanges) = MIDIFile1.Tempo
'Calculate msPerTick at this tempo -- this is used when playing back MIDI input
msPerTick(TotalTempoChanges) = TempoSetting(TotalTempoChanges) / 1000 / MIDIFile1.TicksPerQuarterNote
'Calculate ticksPerMs at this tempo -- this is used when recoding MIDI input
ticksPerMs(TotalTempoChanges) = MIDIFile1.TicksPerQuarterNote / TempoSetting(TotalTempoChanges) * 1000
TempoTime(TotalTempoChanges) = TempoTime(TotalTempoChanges - 1) + MIDIFile1.Time * msPerTick(TotalTempoChanges)
'Display the first tempo
LabelTempo.Caption = Int(60000000 / TempoSetting(1))
'Display TickperQuarterNote
LabelTicks.Caption = MIDIFile1.TicksPerQuarterNote
End If
Next
End Sub
Sub GetTimeSignature ()
Dim m As Integer
MIDIFile1.TrackNumber = 1
For m = 1 To MIDIFile1.MessageCount
MIDIFile1.MessageNumber = m
'Meta Event Key Signature
If (MIDIFile1.Message = 255) And MIDIFile1.Data1 = &H58 Then
LabelTimeSignature.Caption = MIDIFile1.Numerator & "/" & MIDIFile1.Denominator ^ 2
End If
Next
End Sub
Function GetTrackName (Track As Integer) As String
Dim i As Integer
MIDIFile1.TrackNumber = Track
For i = 1 To MIDIFile1.MessageCount
MIDIFile1.MessageNumber = i
'
'Meta Event
'
If (MIDIFile1.Message = 255) And MIDIFile1.Data1 = 3 Then
If (MIDIFile1.MsgText = "") Then
GetTrackName = "Track" & Str(Track) & " (null)"
Else
GetTrackName = MIDIFile1.MsgText
End If
Exit Function
End If
Next
GetTrackName = "Track" & Str(Track)
End Function
Sub InputDevCombo_Click ()
'
' Stop and Close currently opened device (if any)
'
StopRecording
End Sub
Sub MessageList_Click ()
MIDIFile1.MessageNumber = MessageList.ListIndex + 1
TimeEdit.Text = FormatNumber(CLng(MIDIFile1.Time))
MessageEdit.Text = FormatNumber(CLng(MIDIFile1.Message))
Data1Edit.Text = FormatNumber(CLng(MIDIFile1.Data1))
Data2Edit.Text = FormatNumber(CLng(MIDIFile1.Data2))
BufferEdit.Text = MIDIFile1.Buffer
MsgTextEdit.Text = MIDIFile1.MsgText
End Sub
Sub MIDIInput1_Message ()
Dim InMessage As Integer
Dim InData1 As Integer
Dim InData2 As Integer
Dim Y As Integer
If (fGotFirst = False) Then
InPreviousTime = MIDIInput1.Time
fGotFirst = True
fRecording = True
End If
'
'This do while loop allows you to take all the messages that are
'waiting in the message queue.
'
Do While MIDIInput1.MessageCount > 0
'
'This is the incoming MIDI data
'
InMessage = MIDIInput1.Message
InData1 = MIDIInput1.Data1
InData2 = MIDIInput1.Data2
'
' Copy input to output?
'
If (MidiThruCheck.Value) Then
'
'Tell MIDIOutput1 to send the MIDI data
'
MIDIOutput1.Message = InMessage
MIDIOutput1.Data1 = InData1
MIDIOutput1.Data2 = InData2
MIDIOutput1.Action = MIDIOUT_SEND
End If
If (InsertRecordingCheck.Value) And InMessage < 254 Then
' Copy message parameters
MIDIFile1.Message = InMessage
MIDIFile1.Data1 = InData1
MIDIFile1.Data2 = InData2
' Calculate time in ticks
InCurrentTime = MIDIInput1.Time
MIDIFile1.Time = (InCurrentTime - InPreviousTime) * msPerTick(1)
InPreviousTime = InCurrentTime
' insert message into MIDI file
MIDIFile1.Action = MIDIFILE_INSERT_MESSAGE
End If
'
'Remove the MIDI data from the MIDI IN queue
'
MIDIInput1.Action = MIDIIN_REMOVE
Loop
End Sub
Sub MIDIOutput1_Error (ErrorCode As Integer, ErrorMessage As String)
MsgBox ErrorMessage
End Sub
Sub MIDIOutput1_MessageSent (MessageTag As Long)
LabelTempo.Caption = Str$(Int(60000000 / TempoSetting(MessageTag)))
End Sub
Sub MIDIOutput1_QueueEmpty ()
StopPlay
End Sub
Function OkToExit () As Integer
Dim wRtn As Integer
If (fModified) Then
wRtn = MsgBox("Save file before exiting?", 36)
If (wRtn = 6) Then
If (MIDIFile1.Filename = "Untitled.mid") Then
If (SaveAs() = False) Then
OkToExit = False
Exit Function
End If
Else
MIDIFile1.Action = MIDIFILE_SAVE
End If
End If
End If
OkToExit = True
End Function
Sub OpenInputDevice ()
MIDIInput1.DeviceID = InputDevCombo.ListIndex
MIDIInput1.Action = MIDIIN_OPEN
End Sub
Sub OpenOutputDevice ()
'
' Restore defaults
'
PlaybackRateSlider = 0
'
' Open selected device
'
MIDIOutput1.DeviceID = OutputDevCombo.ListIndex - 1
MIDIOutput1.Action = MIDIOUT_OPEN
'
' Save volume if opened ok
'
If (MIDIOutput1.HMidiDevice <> 0) Then
'
' If device supports volume, save starting volume
'
If (MIDIOutput1.HasLRVolume) Then
lVolume = MIDIOutput1.VolumeLeft
rVolume = MIDIOutput1.VolumeRight
ElseIf (MIDIOutput1.HasVolume) Then
lVolume = MIDIOutput1.VolumeLeft
End If
End If
End Sub
Sub OutputDevCombo_Click ()
'
' Stop and Close currently opened device (if any)
'
StopPlay
End Sub
Sub QueueTrack (Track As Integer)
Dim m As Integer
Dim n As Integer
Dim i As Double
Dim TempoChangeCount As Integer
Dim msTickTime As Integer
Dim TimerTagCount As Integer
PreviousTime = 0
CurrentTime = 0
TimerTagCount = 0
Screen.MousePointer = 11
TempoChangeCount = 1
MIDIFile1.TrackNumber = Track
For m = 1 To MIDIFile1.MessageCount
MIDIFile1.MessageNumber = m
'Meta Event
If (MIDIFile1.Message <> 255) Then
'PreviousTime is = to the total ms into the song for this track
'
'Int(MIDIFile1.Time * msPerTick(TempoChangeCount)) is = to the total ms
'that need to pass before playing the next event
'
CurrentTime = PreviousTime + MIDIFile1.Time * msPerTick(TempoChangeCount)
'if the time value of TempoTime(TempoChangeCount) is less than or equal
'to the current time, a tempo change is needed.
'
'Note that msPerTick() is set in Sub GetTempoChanges () at the time a new MIDI
'file is loaded.
If TotalTempoChanges > TempoChangeCount And TempoTime(TempoChangeCount) <= CurrentTime Then
'Use MessageTag property in MIDIOutput1 fire an event at the time the
'tempo changes so that we can change the LabelTempo.Caption.
'
'See: Sub MIDIOutput1_MessageSent for actual updating of LabelTempo.Caption
MIDIOutput1.MessageTag = TempoChangeCount
TempoChangeCount = TempoChangeCount + 1
End If
'Time in ms to send this event
MIDIOutput1.Time = CurrentTime
'Keep track of the CurrentTime for the next event we queue
PreviousTime = CurrentTime
' Put message data in control
MIDIOutput1.Message = MIDIFile1.Message
MIDIOutput1.Data1 = MIDIFile1.Data1
MIDIOutput1.Data2 = MIDIFile1.Data2
' Add to output queue
MIDIOutput1.Action = MIDIOUT_QUEUE
End If
DoEvents
Next
Screen.MousePointer = 0
End Sub
Function SaveAs () As Integer
CMDialog1.DialogTitle = "Save MIDI File As"
On Error Resume Next
CMDialog1.Flags = &H2&
CMDialog1.Action = 2
If (Err) Then
SaveAs = False
Exit Function
End If
On Error GoTo 0
MIDIFile1.Filename = CMDialog1.Filename
MIDIFile1.Action = MIDIFILE_SAVE_AS
SaveAs = True
End Function
Sub StartPlay ()
OpenOutputDevice
MIDIOutput1.Action = MIDIOUT_START
CmdPlay.Enabled = False
CmdRecord.Enabled = False
CmdStop.Enabled = True
End Sub
Sub StartRecording ()
OpenInputDevice
MIDIInput1.Action = MIDIIN_START
'InPreviousTime = MIDIInput1.Time
CmdPlay.Enabled = False
CmdRecord.Enabled = False
CmdStop.Enabled = True
fGotFirst = False
End Sub
Sub StopPlay ()
MIDIOutput1.Action = MIDIOUT_STOP
CloseOutputDevice
CmdPlay.Enabled = True
CmdRecord.Enabled = True
CmdStop.Enabled = False
End Sub
Sub StopRecording ()
MIDIInput1.Action = MIDIIN_STOP
CloseInputDevice
If (MidiThruCheck) Then
CloseOutputDevice
End If
CmdPlay.Enabled = True
CmdRecord.Enabled = True
CmdStop.Enabled = False
fRecording = False
If (InsertRecordingCheck) Then
DisplayTrack (TrackList.ListIndex + 1)
End If
End Sub
Sub TrackList_Click ()
DisplayTrack (TrackList.ListIndex + 1)
End Sub